The 640 MEG Shareware Studio 2/The 640 Meg Shareware Studio CD-ROM Volume II (Data Express)(1993).ISO/pascal/ghostbbs.zip/COMPMESS.PAS

Pascal/Delphi Source File | 1985-12-18 | 5.2 KB | 226 lines

const
maxlength = 50;
maxmess = 400;
numsects = 20;

type
  str2      = string[2];
  name      = string[14];
  longname  = string[25];
  filbuffer = array[0..127] of byte;
  rate      = (slow,fast);
  line      = string[80];
  person    = string[27];
  str10     = string[10];
  long      = string[150];

   messages = record
             sender   :person;
             recver   :longname;
             subject  :longname;
             date     :name;
             messno   :integer;
             pointer  :integer;
        end;

  messrec = record
            mtext  : string[80];
            pmess  : integer;
         end;

   sectrec = record
             sectname : string[25];
             sectaccess : byte;
             specaccess : byte;
           end;

  sectnames = array[1..numsects] of sectrec;
  messtext = array[1..maxlength] of line;

var
  sections : sectnames;
  tempmess : messages;
  messagefile, outmess : file of messages;
  textfile, outtext : file of messrec;
  count: integer;
  messtable: array[0..maxmess] of messages;
  subdir : longname;
  block : messtext;
  tempsub : integer;
  subboard : byte;
  nextmess : byte;
  lastline : byte;
  jj : byte;
  errcode : integer;
  parm : string[10];
  loop : integer;

function namemess(number: integer):line;
{ constructs file name for messages data files}
var  temp:name;
  begin
    str(number,temp);
    namemess := 'MESS' + temp + '.BBS';
  end;

function outnamemess(number: integer):line;
{ constructs file name for messages data files}
var  temp:name;
  begin
    str(number,temp);
   outnamemess := 'XMESS' + temp + '.BBS';
  end;

function nametitle(number: integer):line;
{ constructs file name for messages title files}
var  temp:name;
  begin
    str(number,temp);
    nametitle := 'TITLE' + temp + '.BBS';
  end;

function outnametitle(number: integer):line;
{ constructs file name for messages title files}
var  temp:name;
  begin
    str(number,temp);
    outnametitle := 'XTITL' + temp + '.BBS';
  end;

procedure initmess;
  begin
    writeln('Getting Messages ...');
    count := 0;
    assign(messagefile, nametitle(subboard));
    {$I-} reset(messagefile) {$I+};
    if IOresult = 0
      then begin
        while not eof(messagefile) do
          begin
            count := count + 1;
            read(messagefile, messtable[count]);
          end
      end else rewrite(messagefile);
      close(messagefile);
      nextmess := count + 1;
      assign (textfile,namemess(subboard));
      {$I-}
      reset(textfile);
      {$I+}
      if IoResult <> 0 then rewrite(textfile);
      writeln('There are ', count , ' Messages.');
    end;

procedure closemess;
  var
    loop: byte;
  begin
    assign(messagefile,nametitle(subboard));
    rewrite(messagefile);
    for loop := 1 to count do
      write(messagefile, messtable[loop]);
    close(messagefile);
    close(textfile);
  end;

function transmess(tabloc:byte):boolean;
var
  rtext   : messrec;
begin
  lastline := 1;
  reset(textfile);
  seek(textfile,messtable[tabloc].pointer);
  {$I-}
  read(textfile,rtext);
  {$I+}
  if ioresult <> 0
    then begin
      transmess := false;
      exit;
    end;

  block[lastline] := rtext.mtext;
  while (rtext.pmess > 0) do
    begin
      seek(textfile,rtext.pmess);
      {$I-}
      read(textfile,rtext);
      {$I+}
      if ioresult <> 0
        then begin
          transmess := false;
          exit;
        end;
      lastline := lastline + 1;
      block[lastline] := rtext.mtext;
    end;
  transmess := true;
end;

  var
    tabloc: byte;
    linenum: byte;


  procedure storemess(tabloc: byte);
    var
      linenum: byte;
      freearray : array[1..maxlength] of integer;
      i : integer;
      temp : messrec;

  procedure get_next;
  var i , j ,errcode : integer;
  begin
    errcode := 0;
    i := 0;
    j := 0;
    reset(outtext);
        if filesize(outtext) = 0 then j := 0
                                  else j := filesize(outtext);
        while (i < lastline) do
          begin
            i := i + 1;
            freearray[i] := j;
            j := j + 1;
          end;
      end;

    begin {storemess}
        reset(outtext);
        get_next;
        linenum := 1;
        messtable[tabloc].pointer := freearray[1];
        while linenum <= lastline do begin
          if linenum = lastline then temp.pmess := 0
                                  else temp.pmess := freearray[linenum+1];
          temp.mtext := block[linenum];
          seek(outtext,freearray[linenum]);
          write(outtext,temp);
          linenum := linenum + 1;
        end;
    end;

begin
  parm := paramstr(1);
  val(parm,tempsub,errcode);
  if (errcode <> 0) then exit;
  subboard := tempsub;
  assign(outtext,outnamemess(subboard));
  rewrite(outtext);
  writeln('Compressing message base # ',subboard);
  initmess;
  for jj := 1 to count do
    begin
      writeln('Compressing Message #',jj);
      if transmess(jj)
        then storemess(jj)
        else begin
          for loop := jj + 1 to count do
          messtable[loop-1] := messtable[loop];
          count := count - 1;
        end;
    end;
  close(outtext);
  closemess;
end.